home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
PROGRAM
/
TAN_SND.ARJ
/
DRUMS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-07-28
|
6KB
|
306 lines
unit drums; { DRUMS.PAS Copyright (c) 1990 DSoft Specialties }
interfac { Drum routines for the Tandy 1000 and/or PCJr. See DRUMS.SIM }
uses dos,noiz;
{ All I ask is if you use any of these routines in your program
please mention DSoft in the docs or in a copyright message }
type
echo_style = (short,long);
const
drumpitch: word = 0;
inturbo: boolean = true;
procedure wait(dt: longint);
procedure delay(dt: longint);
procedure drum_pitch(i: word);
procedure down(snd,step: byte;pitch: word);
procedure up(snd,step: byte;pitch: word);
procedure noise(ch: char;sr,amp,duration: word);
procedure dwn(reps,tone,dur: integer);
procedure snare(reps,dur: byte);
procedure tom(reps,dur: byte);
procedure lowtom(reps,dur: byte);
procedure bass(reps,dur: byte);
procedure bass2(reps,dur: byte);
procedure roto1(reps,dur: byte);
procedure roto2(reps,dur: byte);
procedure roto5(reps,tone,dur: integer);
procedure sims(reps,dur: byte);
procedure sims1(reps,dur: byte);
procedure sims2(reps,dur: byte);
procedure sims3(reps,dur: byte);
procedure crash(reps,dur: integer);
procedure roll(reps,dur,crashdur: integer);
procedure lick(reps: byte);
procedure echo(del: word;es: echo_style);
procedure quiet;
function fkey: char;
function keyhit: boolean;
implementation
procedure wait(dt: longint);
const
inturb = 30;
indos = 42;
var tt,ir,tr: longint;
begin
if inturbo then
tt:=inturb
else
tt:=indos;
for ir:=1 to dt do
for tr:=1 to tt do
end;
procedure delay(dt: longint);
begin
wait(dt);
end;
procedure drum_pitch(i: word);
var j: integer;
begin
for j:=0 to 3 do sound_pitch(j,i);
end;
procedure down(snd,step: byte;pitch: word);
var i: byte;
begin
port[$C0]:=$E0+1*4+snd;
for i:=0 to 15 do
begin
port[$C0]:=$F0+i;
wait(step);
end;
drum_pitch(pitch);
end;
procedure up(snd,step: byte;pitch: word);
var i: byte;
begin
port[$C0]:=$E0+1*4+snd;
for i:=15 downto 0 do
begin
port[$C0]:=$F0+i;
wait(step);
end;
port[$C0]:=$FF;
drum_pitch(pitch);
end;
procedure noise(ch: char;sr,amp,duration: word);
var portpass1: integer;
begin
portpass1:=224;
if (ch in ['W','w']) then portpass1:=portpass1 + 4;
case sr of
10: portpass1:=portpass1 + 1;
20: portpass1:=portpass1 + 2;
end;
port[$C0]:=240+amp;
port[$C0]:=portpass1;
wait(duration);
end;
procedure dwn(reps,tone,dur: integer);
var i,j,k: integer;
begin
for i:=1 to reps do
begin
for j:=0 to 15 do
begin
noise('w',tone,j,dur); noise(' ',0,15,1);
end;
end;
end;
procedure snare(reps,dur: byte);
var i: byte;
begin
for i:=1 to reps do down(0,dur,drumpitch);
end;
procedure tom(reps,dur: byte);
var i: byte;
begin
drumpitch:=0;
for i:=1 to reps do down(1,dur,drumpitch);
end;
procedure lowtom(reps,dur: byte);
var i: byte;
begin
for i:=1 to reps do down(2,dur,drumpitch);
end;
procedure bass(reps,dur: byte);
var i: byte;
begin
for i:=1 to reps do down(3,dur,0);
end;
procedure bass2(reps,dur: byte);
var i: byte;
begin
for i:=1 to reps do
begin
down(3,dur div 2,drumpitch);
down(2,dur div 2,drumpitch);
end;
end;
procedure roto1(reps,dur: byte);
var i,j: integer;
begin
for i:=1 to reps do
begin
up(1,dur,20); down(2,dur,0);
end;
end;
procedure roto2(reps,dur: byte);
var i,j: integer;
begin
for i:=1 to reps do
begin
up(2,1,0);
for j:=140 to 340 do sound(j);
wait(dur); nosound;
end;
drumpitch:=0;
end;
procedure roto5(reps,tone,dur: integer);
var i,j: integer;
begin
for i:=1 to reps do
begin
dwn(1,tone,dur);
end;
end;
procedure sims(reps,dur: byte);
var i,j: byte;
begin
for i:=1 to reps do
begin
up(1,1,0);
for j:=220 downto 23 do sound(j);
nosound;
wait(dur);
end;
end;
procedure sims1(reps,dur: byte);
var i,j: integer;
begin
for i:=1 to reps do
begin
up(1,1,0);
for j:=440 downto 230 do sound(j);
nosound;
wait(dur);
end;
end;
procedure sims2(reps,dur: byte);
var i,j: integer;
begin
for i:=1 to reps do
begin
up(1,1,0);
for j:=880 downto 660 do sound(j);
nosound;
wait(dur);
end;
end;
procedure sims3(reps,dur: byte);
var i,j: integer;
begin
for i:=1 to reps do
begin
up(1,1,0);
for j:=1020 downto 880 do sound(j);
nosound;
wait(dur);
end;
end;
procedure crash(reps,dur: integer);
var i: byte;
begin
for i:=1 to reps do
begin
up(0,4,0);
down(0,dur,0);
end;
end;
procedure roll(reps,dur,crashdur: integer);
var i,j: integer;
begin
for j:=1 to reps do
begin
snare(4,dur);
tom(4,dur);
lowtom(4,dur);
bass(4,dur);
end;
if (crashdur > 0) then
begin
up(0,1,0); down(0,crashdur,0);
end;
end;
procedure lick(reps: byte);
begin
up(1,3,drumpitch); up(0,3,drumpitch); up(2,3,drumpitch);
lowtom(4,2); tom(4,2);
sims(4,15); up(2,3,drumpitch);
roll(reps,2,22);
end;
procedure quiet;
begin
noiz.quiet;
end;
procedure echo(del: word;es: echo_style);
var i: integer;
begin
for i:=0 to 15 do
begin
noiz.noise('w',20,i,del); noiz.noise('w',10,i,2);
noiz.noise('w',0,i,2);
case es of
short: noiz.noise(' ',5,15,0);
long: noiz.noise(' ',5,15,del);
end;
end;
end;
function fkey: char;
var regs: registers;
begin
regs.AH:=0;
intr($16,regs);
if regs.AL=0 then
fkey:=chr(regs.AH+128)
else
fkey:=chr(regs.AL)
end;
function keyhit: boolean;
var regs: registers;
begin
regs.AH:=1;
intr($16,regs);
keyhit:=(regs.flags and 64)=0;
end;
end.